home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / derived / text-binary.scm < prev   
Encoding:
Text File  |  1994-09-27  |  6.7 KB  |  235 lines  |  [TEXT/CCL2]
  1. ;;; ----------------------------------------------------------------
  2. ;;;  Text
  3. ;;; ----------------------------------------------------------------
  4.  
  5. (define (text-fns algdata suppress-reader?)
  6.   (let ((print+read
  7.      (cond ((algdata-enum? algdata)
  8.         (text-enum-fns algdata suppress-reader?))
  9.            (else
  10.         (text-general-fns algdata suppress-reader?)))))
  11.     print+read))
  12.  
  13. (define (text-enum-fns algdata suppress-reader?)
  14.   (cons
  15.    (**define '|showsPrec| '(|d| |x|)
  16.       (**case/con algdata (**var '|x|)
  17.           (lambda (con vars)
  18.              (declare (ignore vars))
  19.              (**showString (**string (con-string con))))))
  20.    (if suppress-reader?
  21.        '()
  22.        (list
  23.     (**define '|readsPrec| '(|d| |str|)
  24.           (**listcomp
  25.        (**var '|s|)
  26.        (list
  27.         (**gen '(tuple |tok| |rest|) (**lex (**var '|str|)))
  28.         (**gen '|s|
  29.              (**case (**var '|tok|)
  30.                  `(,@(map (lambda (con)
  31.                     (**alt/simple
  32.                      (**pat (con-string con))
  33.                      (**list (**tuple2 (**con/def con)
  34.                                (**var '|rest|)))))
  35.                       (algdata-constrs algdata))
  36.                    ,(**alt/simple (**pat '_) (**null))))))))))))
  37.  
  38. ;;; This has been hacked to split up the read function for large
  39. ;;; data types to avoid choking the lisp compiler.
  40.  
  41. (define (text-general-fns algdata suppress-reader?)
  42.  (let ((split-fn-def? (> (algdata-n-constr algdata) 6)))  ;; pretty arbitrary!
  43.   (cons
  44.    (**define '|showsPrec| '(|d| |x|)
  45.        (**case/con algdata (**var '|x|)
  46.       (lambda (con vars)
  47.         (if (con-infix? con)
  48.         (show-infix con vars)
  49.         (show-prefix con vars)))))
  50.    (if suppress-reader?
  51.        '()
  52.        (list
  53.     (**define '|readsPrec| '(|d| |str|)
  54.       (**append/l
  55.        (map (lambda (con)
  56.           (cond ((con-infix? con)
  57.              (read-infix con))
  58.             (else
  59.              (read-prefix con split-fn-def?))))
  60.         (algdata-constrs algdata)))))))))
  61.  
  62. (define (show-infix con vars)
  63.   (multiple-value-bind (p lp rp) (get-con-fixity con)
  64.     (**showParen
  65.      (**< (**Int p) (**var '|d|))
  66.      (**dot (**showsPrec (**int lp) (**var (car vars)))
  67.         (**showString
  68.           (**string (string-append " " (con-string con) " ")))
  69.         (**showsPrec (**int rp) (**var (cadr vars)))))))
  70.  
  71. (define (show-prefix con vars)
  72.   (if (null? vars)
  73.       (**showString (**string (con-string con)))
  74.       (**showParen
  75.        (**<= (**int 10) (**var '|d|))
  76.        (**dot/l (**showString (**string (con-string con)))
  77.         (show-fields vars)))))
  78.  
  79. (define (show-fields vars)
  80.   (if (null? vars)
  81.       '()
  82.       `(,(**space) ,(**showsPrec (**int 10) (**var (car vars)))
  83.     ,@(show-fields (cdr vars)))))
  84.  
  85. (define (read-infix con)
  86.   (multiple-value-bind (p lp rp) (get-con-fixity con)
  87.     (**let
  88.      (list
  89.       (**define '|readVal| '(|r|) 
  90.      (**listcomp
  91.       (**tuple2 (**app (**con/def con) (**var '|u|) (**var '|v|))
  92.             (**var '|s2|))
  93.       (list
  94.        (**gen '(tuple |u| |s0|)
  95.           (**readsPrec (**int lp) (**var '|r|)))
  96.        (**gen `(tuple ,(con-string con) |s1|)
  97.           (**lex (**var '|s0|)))
  98.        (**gen '(tuple |v| |s2|)
  99.           (**readsprec (**int rp) (**var '|s1|)))))))
  100.      (**readParen (**< (**int p) (**var '|d|))
  101.           (**var '|readVal|) (**var '|str|)))))
  102.  
  103. (define (read-prefix con split?)
  104.   (let ((res (read-prefix-1 con)))
  105.     (if (not split?)
  106.     res
  107.     (dynamic-let ((*module-name* (def-module con)))
  108.      (dynamic-let ((*module* (table-entry *modules* *module-name*)))
  109.         (let* ((alg (con-alg con))
  110.          (fn (make-new-var
  111.               (string-append (symbol->string (def-name alg))
  112.                      "/read-"
  113.                      (remove-con-prefix
  114.                       (symbol->string (def-name con))))))
  115.          (new-code (**app (**var/def fn) (**var '|str|) (**var '|d|)))
  116.          (def (**define fn '(|str| |d|) res)))
  117.       (setf (module-decls *module*) (cons def (module-decls *module*)))
  118.       new-code))))))
  119.  
  120. (define (read-prefix-1 con)
  121.   (let* ((arity (con-arity con))
  122.      (vars (temp-vars "x" arity))
  123.      (svars (cons '|rest| (temp-vars "s" arity))))
  124.     (**let
  125.      (list
  126.       (**define '|readVal| '(|r|) 
  127.         (**listcomp
  128.      (**tuple2 (**app/l (**con/def con) (map (function **var) vars))
  129.            (**var (car (reverse svars))))
  130.      (cons
  131.       (**gen `(tuple ,(con-string con) |rest|)
  132.          (**lex (**var '|r|)))
  133.       (read-fields vars svars (cdr svars))))))
  134.      (**readParen (**< (**int 9) (**var '|d|))
  135.           (**var '|readVal|) (**var '|str|)))))
  136.  
  137. (define (read-fields vars s0 s1)
  138.   (if (null? vars)
  139.       '()
  140.       (cons
  141.        (**gen `(tuple ,(car vars) ,(car s1))
  142.           (**readsprec (**int 10) (**var (car s0))))
  143.        (read-fields (cdr vars) (cdr s0) (cdr s1)))))
  144.  
  145.  
  146. ;;; ----------------------------------------------------------------
  147. ;;;  Binary
  148. ;;; ----------------------------------------------------------------
  149.  
  150. (define (binary-fns algdata)
  151.  (let ((res
  152.   (cond ((algdata-enum? algdata)
  153.      (binary-enum-fns algdata))
  154.     ((algdata-tuple? algdata)
  155.      (binary-tuple-fns algdata))
  156.     (else
  157.      (binary-general-fns algdata)))))
  158. ;   (dolist (x res)
  159. ;       (fresh-line)
  160. ;       (pprint x))
  161.    res))
  162.  
  163.  
  164. (define (binary-enum-fns algdata)
  165.   (list
  166.     (**define '|showBin| '(|x| |b|)
  167.     (**showBinInt (**con-number (**var '|x|) algdata) (**var '|b|)))
  168.     (**define '|readBin| '(|b|)
  169.       (**let
  170.        (list
  171.     (**define '(tuple |n| |b1|) '()
  172.        (**readBinSmallInt
  173.         (**var '|b|)
  174.         (**int (1- (algdata-n-constr algdata))))))
  175.         (**tuple2
  176.      (**case/int algdata (**var '|n|)
  177.            (lambda (con)
  178.          (**con/def con)))
  179.      (**var '|b1|))))))
  180.  
  181. (define (binary-tuple-fns algdata)
  182.   (let* ((con (tuple-con algdata))
  183.      (arity (con-arity con))
  184.      (vars (temp-vars "v" arity)))
  185.     (list
  186.       (**define '|showBin| `((,con ,@vars) |b|)
  187.       (show-binary-body vars '|b|))
  188.       (**define '|readBin| '(|b|)
  189.       (read-binary-body con)))))
  190.  
  191. (define (show-binary-body vars b)
  192.   (**foldr (lambda (new-term prev-terms)
  193.            (**showBin new-term prev-terms))
  194.        (map (function **var) vars)
  195.        (**var b)))
  196.  
  197. (define (read-binary-body con)
  198.   (let* ((arity (con-arity con))
  199.      (vars (temp-vars "v" arity))
  200.      (bvars (cons '|b| (temp-vars "b" arity))))
  201.     (**let
  202.      (map (lambda (v b nb)
  203.         (**define `(tuple ,v ,nb) '()
  204.               (**readBin (**var b))))
  205.       vars bvars (cdr bvars))
  206.      (**tuple2
  207.       (**app/l (**con/def con)
  208.            (map (function **var) vars))
  209.       (**var (car (reverse bvars)))))))
  210.  
  211. (define (binary-general-fns algdata)
  212.   (list
  213.     (**define '|showBin| '(|x| |b|)
  214.       (**showBinInt
  215.        (**con-number (**var '|x|) algdata)
  216.        (**case/con algdata (**var '|x|)
  217.       (lambda (con vars)
  218.         (declare (ignore con))
  219.         (show-binary-body vars '|b|)))))
  220.     (**define '|readBin| '(|bin|)
  221.       (**let
  222.        (list
  223.     (**define '(tuple |i| |b|) '()
  224.      (**readBinSmallInt (**var '|bin|)
  225.                 (**int (1- (algdata-n-constr algdata))))))
  226.        (**case/int algdata (**var '|i|) (function read-binary-body))))))
  227.  
  228. (define (get-con-fixity con)
  229.   (let ((fixity (con-fixity con)))
  230.     (if (not (eq? fixity '#f))
  231.     (let ((p (fixity-precedence fixity))
  232.           (a (fixity-associativity fixity)))
  233.       (values p (if (eq? a 'L) p (1+ p)) (if (eq? a 'R) p (1+ p))))
  234.     (values 9 10 9))))
  235.